home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / sprdet.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  9.3 KB  |  305 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module sprdet)
  13.  
  14. ;; THIS IS THE NEW DETERMINANT PACKAGE
  15.  
  16. (DECLARE-TOP(SPECIAL X *ptr* *ptc* *blk* $SPARSE $RATMX ML* *DETSIGN* RZL*) (GENPREFIX ND))
  17.  
  18. (DEFUN SPRDET(AX N)
  19.   (DECLARE(FIXNUM N))
  20.   (setq ax (get-array-pointer ax))
  21.   (PROG ((J 0) RODR CODR BL DET (DM 0) (R 0) (I 0))
  22.     (DECLARE(FIXNUM I J DM R))
  23.        (SETQ DET 1.)
  24.        (setq  *PTR* (*ARRAY nil T  (f1+ N)))
  25.        (setq  *PTC* (*ARRAY nil T  (f1+ N)))
  26.        (SETQ BL (TMLATTICE AX '*PTR* '*PTC* N))
  27.        (COND ((NULL BL)(RETURN 0)))
  28.        (SETQ RODR(APPLY(FUNCTION APPEND) BL))
  29.        (SETQ CODR(MAPCAR (FUNCTION CADR) RODR))
  30.        (SETQ RODR(MAPCAR (FUNCTION CAR) RODR))
  31.        (SETQ DET(*(PRMUSIGN RODR)(PRMUSIGN CODR)))
  32.        (SETQ BL (MAPCAR (FUNCTION LENGTH) BL ))
  33.  LOOP1 (COND ((NULL BL) (RETURN DET)))
  34.        (SETQ I (CAR BL) )(SETQ DM I)
  35.        (setq  *BLK* (*ARRAY nil T (f1+ DM)(f1+ DM)))
  36.        (COND ((= DM 1.)
  37.           (SETQ DET (GPTIMES DET (CAR(AREF AX (AREF *PTR* (f1+ R))(AREF *PTC*(f1+ R))))))
  38.           (GO NEXT))
  39.         ((= DM 2.)
  40.          (SETQ DET (GPTIMES DET
  41.                 (GPDIFFERENCE
  42.                  (GPTIMES (CAR (AREF AX (AREF *PTR* (f1+ R))(AREF *PTC* (f1+ R))))
  43.                       (CAR (AREF AX (AREF *PTR* (f+ 2. R))(AREF *PTC* (f+ 2. R)))))
  44.                  (GPTIMES (CAR (AREF AX (AREF *PTR* (f1+ R))(AREF *PTC* (f+ 2. R))))
  45.                       (CAR (AREF AX (AREF *PTR* (f+ 2. R))(AREF *PTC* (f1+  R))))))))
  46.          (GO NEXT)))
  47.        LOOP2 (COND ((= I 0)(GO CMP)))
  48.        (SETQ J DM)
  49.        LOOP3 (COND ((= J 0) (SETQ I (f1- I)) (GO LOOP2)))
  50.        (STORE (aref *BLK* I J)(CAR  (AREF AX  (AREF *PTR* (f+ R I))  (AREF *PTC*(f+ R J)))))
  51.        (SETQ J (f1- J)) (GO LOOP3)
  52.        CMP
  53.        (SETQ DET (GPTIMES DET (TDBU '*BLK* DM)))
  54.        NEXT   
  55.        (SETQ R(f+ R DM))
  56.        (SETQ BL (CDR BL))
  57.        (GO LOOP1)
  58.        ))
  59.  
  60. (DEFUN MINORL (X N L NZ)
  61.   (DECLARE(FIXNUM  N ))
  62.   (PROG (ANS S RZL* (COL 1) ( N2 (// N 2.))  D DL Z A ELM RULE)
  63.       (DECLARE(FIXNUM N2  COL ))
  64.        (SETQ N2(f1- N2))
  65.        (SETQ DL L L NIL NZ (CONS NIL NZ))
  66.        L1(COND((NULL NZ)(RETURN ANS)))
  67.        L3(SETQ Z (CAR NZ))
  68.        (COND ((NULL L) (COND (DL (SETQ ANS (CONS DL ANS)))
  69.                  (T (RETURN NIL)))
  70.                (SETQ NZ (CDR NZ) COL (f1+ COL) L DL DL NIL)
  71.                (GO L1)))
  72.        (SETQ A (CAAR L) )
  73.        L2(COND((NULL Z)
  74.            (COND (RULE (RPLACA (CAR L) (LIST A RULE))
  75.                (SETQ RULE NIL) (SETQ L (CDR L)))
  76.              ((NULL (CDR L))
  77.               (RPLACA (CAR L) (LIST A 0))
  78.               (SETQ L (CDR L)))
  79.              (T (RPLACA L (CADR L))
  80.             (RPLACD L (CDDR L))))
  81.            (GO L3)))
  82.        (SETQ ELM (CAR Z) Z (CDR Z))
  83.        (SETQ S(SIGNNP ELM A))
  84.        (COND(S(SETQ D (zl-DELETE ELM (COPY1 A)))
  85.           (COND((MEMBERCAR D DL) (GO ON))
  86.            (T
  87.             (COND((OR(< COL N2)(NOT(SINGP X D COL N)))(SETQ DL (CONS (CONS D 1) DL))(GO ON)))
  88.             ))))
  89.        (GO L2)
  90.        ON(SETQ RULE(CONS (LIST D S ELM (f1- COL)) RULE))
  91.        (GO L2)))
  92.  
  93. #-NIL
  94. (DECLARE-TOP(SPECIAL J))
  95.  
  96. (DEFUN SINGP (X ML COL N)
  97.     #+cl (DECLARE (FIXNUM COL N))
  98.   ;#-Multics (DECLARE (FIXNUM COL N I J))
  99.   (PROG (I (J col) L) 
  100.     (DECLARE (FIXNUM  J))
  101.     (SETQ L ML)
  102.     (COND((NULL ML)(GO LOOP))
  103.          (T (SETQ I (CAR ML) ML (CDR ML))))
  104.     (COND((zl-MEMBER I RZL*)(RETURN T))
  105.          ((ZROW X I COL N)(RETURN (SETQ RZL*(CONS I RZL*)))))
  106.     LOOP(COND((> J N)(RETURN NIL))
  107.          ((EVERY #'(LAMBDA (I) (EQUAL (AREF X I J) 0)) L)
  108.           (RETURN T)))
  109.     (SETQ J(f1+ J))(GO LOOP)
  110.     ))
  111. #-NIL
  112. (DECLARE-TOP(UNSPECIAL J))
  113.  
  114. (DEFUN TDBU (X N)
  115.   (DECLARE(FIXNUM N))
  116.   (PROG(A ML* NL NML DD)
  117.        (SETQ *DETSIGN* 1)
  118.       (setq x ( get-array-pointer x))
  119.        (DETPIVOT X N)
  120.        (SETQ X (get-array-pointer 'X*))
  121. ;       (setq x ( get-array-pointer x))
  122.        (SETQ NL (NZL X N))
  123.        (COND ((MEMQ NIL NL)(RETURN 0)))
  124.        (SETQ A (MINORL X N (LIST (CONS (NREVERSE(INDEX* N)) 1)) NL))
  125.        (SETQ NL NIL)
  126.        (COND ((NULL A)(RETURN 0)))
  127.        (TB2 X  (CAR A)N)
  128.        TAG2
  129.        (SETQ ML*(CONS (CONS NIL NIL)(CAR A)))
  130.        (SETQ A (CDR A))
  131.        (COND ((NULL A) (RETURN (COND ((= *DETSIGN* 1) (CADADR ML*))
  132.                      (T (GPCTIMES -1  (CADADR ML*)))))))
  133.        (SETQ NML (CAR A))
  134.        TAG1(COND((NULL NML)(GO TAG2)))
  135.        (SETQ DD  (CAR NML))
  136.        (SETQ NML (CDR NML))
  137.        (NBN DD)
  138.        (GO TAG1)
  139.        ))
  140.  
  141. (DEFUN NBN (RULE)
  142.   (declare (special x))
  143.   (PROG (ANS R A)
  144.        (SETQ ANS 0 R (CADAR RULE))
  145.        (COND ((EQUAL R 0) (RETURN 0)))
  146.        (RPLACA RULE (CAAR RULE))
  147.        LOOP(COND((NULL R) (RETURN(RPLACD RULE(CONS ANS (CDR RULE))))))
  148.        (SETQ A (CAR R) R(CDR R))
  149.        (SETQ ANS(GPPLUS ANS
  150.             (GPTIMES
  151.              (COND ((= (CADR A) 1)
  152.                 (AREF X (CADDR A) (CADDDR A)))
  153.                    (T (GPCTIMES (CADR A) (AREF X (CADDR A) (CADDDR A)))))
  154.              (GETMINOR (CAR A)))))
  155.        (GO LOOP)))
  156.  
  157. (DEFUN GETMINOR (INDEX)
  158.        (COND((NULL(SETQ INDEX(zl-ASSOC INDEX ML*)))0)
  159.         (T(RPLACD (CDR INDEX)(f1- (CDDR INDEX)))
  160.           (COND((= (CDDR INDEX )0)
  161.             (zl-DELETE INDEX ML*)))
  162.           (CADR INDEX)))
  163.        )
  164.  
  165. (DEFUN TB2 (X L N)
  166.   (DECLARE(FIXNUM N ))
  167. ;  (setq x (get-array-pointer x))
  168.   (PROG( ( N-1(f1- N)) B A)
  169.   (DECLARE(FIXNUM  N-1))
  170.        LOOP(COND((NULL L) (RETURN NIL)))
  171.        (SETQ A (CAR L) L (CDR L)B (CAR A))
  172.        (RPLACD A (CONS (GPDIFFERENCE(GPTIMES (AREF X (CAR B) N-1) (AREF X (CADR B) N))
  173.                     (GPTIMES (AREF X (CAR B) N) (AREF X (CADR B) N-1)))
  174.                (CDR A)))
  175.        (GO LOOP)
  176.        ))
  177.  
  178. (DEFUN ZROW (X I COL N)
  179.        (DECLARE(FIXNUM I COL N ))
  180. ;    (setq x (get-array-pointer x))
  181.        (PROG((J COL))
  182.         (DECLARE(FIXNUM  J))
  183.         LOOP(COND((> J N)(RETURN T))
  184.              ((EQUAL (AREF X I J) 0)(SETQ J(f1+ J))(GO LOOP)))
  185.         ))
  186.  
  187. (DEFUN NZL (A N)
  188.   (DECLARE(FIXNUM N ))
  189.   
  190. ;  (setq a (get-array-pointer a))
  191.        (PROG((I 0)( J (f- N 2)) D L)
  192.         (DECLARE(FIXNUM  I J))
  193.         LOOP0(COND((= J 0) (RETURN L)))
  194.         (SETQ I N)
  195.         LOOP1(COND((= I 0) (SETQ L (CONS D L)) (SETQ D NIL)(SETQ J (f1- J))(GO LOOP0)))
  196.         (COND((NOT(EQUAL (AREF A I J) 0))(SETQ D (CONS I D))))
  197.         (SETQ I (f1- I))(GO LOOP1)
  198.         ))
  199.  
  200. (DEFUN SIGNNP (E L)
  201.        (PROG(I)
  202.         (SETQ I 1)
  203.         LOOP (COND ((NULL L)(RETURN NIL))
  204.                ((EQUAL E (CAR L)) (RETURN I)))
  205.         (SETQ L(CDR L) I (f- I))
  206.         (GO LOOP)
  207.         ))
  208.  
  209. (DEFUN MEMBERCAR (E L)
  210.        (PROG()
  211.         LOOP(COND((NULL L)(RETURN NIL))
  212.              ((EQUAL E (CAAR L))(RETURN(RPLACD (CAR L) (f1+ (CDAR L))))))
  213.         (SETQ L (CDR L))(GO LOOP)
  214.         ))
  215.  
  216. (DECLARE-TOP (UNSPECIAL X ML* RZL*))
  217.  
  218. (DEFUN ATRANSPOSE (A N)
  219.        (PROG(I J D) (SETQ I 0)
  220.         LOOP1(SETQ I (f1+ I) J I)
  221.         (COND ((> I N) (RETURN NIL)))
  222.         LOOP2 (SETQ J (f1+ J))
  223.         (COND ((> J N) (GO LOOP1)))
  224.         (SETQ D (AREF A I J))
  225.         (STORE (AREF A I J) (AREF A J I))
  226.         (STORE (AREF A J I) D)
  227.         (GO LOOP2)
  228.         ))
  229.  
  230. (DEFUN MXCOMP (L1 L2)
  231.        (PROG()
  232.         LOOP(COND((NULL L1)(RETURN T))
  233.              ((CAR> (CAR L1) (CAR L2))(RETURN T))
  234.              ((CAR> (CAR L2) (CAR L1))(RETURN NIL)))
  235.         (SETQ L1 (CDR L1) L2 (CDR L2))(GO LOOP)
  236.         ))
  237.  
  238. (DEFUN PRMUSIGN (L)
  239.        (PROG((B 0) A D)
  240.         (DECLARE(FIXNUM B))
  241.         LOOP (COND((NULL L)(RETURN (COND((EVEN B) 1)(T -1)))))
  242.         (SETQ A (CAR L) L (CDR L) D L )
  243.         LOOP1 (COND ((NULL D) (GO LOOP))
  244.             ((> A (CAR D)) (SETQ B (f1+ B))))
  245.         (SETQ D (CDR D))(GO LOOP1)
  246.         ))
  247.  
  248. (DEFUN DETPIVOT (X N)
  249.        (PROG(R0 C0)
  250.         (SETQ C0 (COLROW0 X N NIL) R0(COLROW0 X N T))
  251.         (SETQ C0 (NREVERSE(BBSORT C0 (FUNCTION CAR>))))
  252.         (SETQ  R0 (NREVERSE(BBSORT R0 (FUNCTION CAR>))))
  253.         (COND ((NOT(MXCOMP C0 R0))(ATRANSPOSE X N)(SETQ C0 R0)))
  254.         (SETQ *DETSIGN* (PRMUSIGN (MAPCAR (FUNCTION CAR) C0)))
  255.         (NEWMAT 'X* X N C0)
  256.         (*REARRAY X)))
  257.  
  258. (DEFUN NEWMAT(X Y N L)
  259. ;  (setq y (get-array-pointer y))
  260.   (PROG (I J JL)
  261.     ;(set x   (*ARRAY  nil T (f1+ N) (f1+ N)))
  262.     (set x   (*ARRAY  nil T (f1+ N) (f1+ N)))
  263.     (setq x (get-array-pointer x))
  264.     (SETQ J 0.)
  265.    LOOP (SETQ I 0 J (f1+ J))
  266.     (COND ((NULL L) (RETURN NIL)))
  267.     (SETQ JL (CDAR L) L (CDR L))
  268.     TAG (SETQ I (f1+ I))
  269.     (COND ((> I N)(GO LOOP)))
  270.     (STORE (AREF X I J) (AREF Y I JL))
  271.     (GO TAG)))
  272.  
  273. (DEFUN CAR> (A B) (> (CAR A) (CAR B)))
  274.  
  275. (COMMENT IND=T FOR ROW ORTHERWISE COL)
  276.  
  277. (DEFUN COLROW0 (A N IND)
  278.   (DECLARE(FIXNUM N ))
  279. ;  (setq a (get-array-pointer a))
  280.   (PROG ((I 0) (J n)  L (C 0))
  281.   (DECLARE(FIXNUM i  C J))
  282.   LOOP0 (COND((= J 0) (RETURN L)))
  283.         (SETQ I N)
  284.   LOOP1 (COND ((= I 0)
  285.            (SETQ L (CONS (CONS C J) L))
  286.            (SETQ C 0.)
  287.            (SETQ J (f1- J))
  288.            (GO LOOP0)))
  289.         (COND ((EQUAL (COND (IND (AREF A J I))
  290.                 (T (AREF A I J))) 0)
  291.            (SETQ C (f1+ C))))
  292.        (SETQ I (f1- I))(GO LOOP1)
  293.        ))
  294.  
  295. (DEFUN GPDIFFERENCE (A B)
  296.        (COND ($RATMX (PDIFFERENCE A B))
  297.          (T (SIMPLUS(LIST '(MPLUS) A (LIST '(MTIMES) -1 B)) 1 NIL))))
  298.  
  299. (DEFUN GPCTIMES(A B) (COND ($RATMX (PCTIMES A B)) (T (SIMPTIMES(LIST '(MTIMES) A B) 1 NIL))))
  300.  
  301. (DEFUN GPTIMES(A B) (COND ($RATMX (PTIMES A B)) (T(SIMPTIMES (LIST '(MTIMES) A B) 1 NIL))))
  302.  
  303. (DEFUN GPPLUS(A B) (COND ($RATMX (PPLUS A B)) (T (SIMPLUS(LIST '(MPLUS) A B) 1 NIL))))
  304.  
  305.